perm filename CLEFS.F4[NEW,LCS]9 blob
sn#355374 filedate 1978-05-14 generic text, type T, neo UTF8
C**** CLEFS, MOVER, MARKS ********* READ, OUTIT (THESE FOR PRESCN)
SUBROUTINE CLEFS
DIMENSION KPNT1(11),JCLEF(1750),RCMIN(4),KPNT2(11),KCLEF(350)
1,CM(4),LCLEF(350),KPNT3(11),MCLEF(350),NCLEF(350)
1,KPNT4(11),KPNT5(11)
COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS,XDIS/BM/F,G,H
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /MIN/MINI,RMINI
DATA RCMIN/3.3,10.5,7.0,10.5/,CM/.1,1.5,1.1,1.5/,XDIS/1.0/
EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J9,JQ(7)),(KK,KPNT2
1(11)),(R6,RJQ(4)),(R5,RJQ(3)),(R8,RJQ(6)),(R7,RJQ(5)),(J8,JQ(6))
1,(DEG,R9,RJQ(7)),(NJR,RJQ(8)),(KJ,KPNT1(11)),(KCLEF,JCLEF(351))
1,(R3,RJQ(1)),(LCLEF,JCLEF(701)),(KL,KPNT3(11)),(KM,KPNT4(11))
1,(MCLEF,JCLEF(1051)),(NCLEF,JCLEF(1401)),(KN,KPNT5(11))
CX J5=MOD(J5,100)
CX IF(J5)J5=-J5
IF(R6.GE.100)R6=R6-100
C SOMETIMES MAKE SIZE +100 FOR PARTS PROGRAM.
CALL NOZERO(R6)
IF(R7.EQ.0)R7=R6
C IF P7 = 0, IT WILL EQUAL P6.
IF(JA.GT.10)GO TO 9
NAME='CLEFA'
IF(J5.LT.20)GO TO 4
R6=R6*.3
C SIZE FACTORS FOR SPECIAL WORDS, ETC. (PPP, MF, CRESC. ETC.)
R7=R7*.3
GO TO 4
9 IF(NAME.EQ.NJR)GO TO 4
IF(NAME.EQ.0)GO TO 177
IF(NJR.EQ.0)GO TO 4
177 IF(NJR.EQ.0)GO TO 8
C TO PICK UP BASIC DRAW NAME FROM P10
NAME=NJR
GO TO 4
8 CALL TYPSTR('SET P10=1')
CALL TYPCRLF
CCC8 TYPE 5
CCC5 FORMAT(' SET P10=1'/)
C LEADS TO PROPER FILE CALL
4 JTAIL=-1
IF(JA.NE.3)GO TO 44
IF(R5.NE.0.8)GO TO 44
JTAIL=0
C R5=0.8 FOR TREBLE CLEF WITH 8 ON TAIL. (FOR TENOR VOCAL)
44 NM=NAME+2*(J5/10)
C DRAW0 HAS ITEMS 0→9; DRAW1, 10→19; ETC. TO DRAW9, 90→99
JEZ=MOD(J5,10)+1
2 IF(NM.EQ.NM1)GO TO 30
IF(NM.EQ.NM2)GO TO 30
IF(NM.EQ.NM3)GO TO 30
IF(NM.EQ.NM4)GO TO 30
IF(NM.EQ.NM5)GO TO 30
C SET P10≠0 TO CHANGE BASIC 'DRAW' NAME.
C JUMP IF ALREADY IN CORE
NPP=0
IF(JA.NE.11)GO TO 1111
C DOESN'T CHECK LOOKUP ON CLEFS AND ALPHA'S.
NPP=-1
IF(LOOKF(NM))GO TO 1111
CCC TYPE 1112,NM
CALL TYPWRD(NM)
CALL TYPSTR(' -- NOT FOUND')
1112 CALL TYPCRLF
RETURN
CCC1112 FORMAT(1XA5,' -- NOT FOUND')
1111 CALL GETFI2(NM,NPP)
IF(NPP.LE.0)GO TO 1113
CCC TYPE 1114,NM
CALL TYPWRD(NM)
CALL TYPSTR('.DMD NOT FOUND*****')
GO TO 1112
CCC1114 FORMAT(1XA5,'.DMD NOT FOUND*****')
1113 GO TO(33,233,333,433),KX
C GOES TO 133 WHEN KX IS 0
133 KX=1
NM1=NM
CALL FASTI2(KPNT1,11)
CALL FASTI2(JCLEF,KJ)
C NEW DATA READER 6/74 -- 5/75 HOLDS 5 .DMD FILES IF THEY FIT.
IF(KJ.LE.350)GO TO 30
KX=0
NM2=0
GO TO 30
33 CALL FASTI2(KPNT2,11)
KX=0
IF(KK.GT.350)GO TO 1111
C JUMP BACK IF IT WON'T FIT.
CALL FASTI2(KCLEF,KK)
NM2=NM
KX=2
GO TO 30
233 CALL FASTI2(KPNT3,11)
KX=0
IF(KL.GT.350)GO TO 1111
C JUMP BACK IF IT WON'T FIT.
CALL FASTI2(LCLEF,KL)
KX=3
NM3=NM
C CHECK THE ABOVE -- FOR P5 HEIGHT CHANGE *********************
C R6 IS SIZE FACTOR
GO TO 30
333 CALL FASTI2(KPNT4,11)
KX=0
IF(KM.GT.350)GO TO 1111
C JUMP BACK IF IT WON'T FIT.
CALL FASTI2(MCLEF,KM)
KX=4
NM4=NM
GO TO 30
433 CALL FASTI2(KPNT5,11)
KX=0
IF(KN.GT.350)GO TO 1111
C JUMP BACK IF IT WON'T FIT.
CALL FASTI2(NCLEF,KN)
NM5=NM
30 IF(J5.GT.3)GO TO 811
IF(JA.NE.3)GO TO 811
C 0=TREB, 1=BASS, 2=ALTO, 3=TENOR(ALTO SHIFTED UP)
C ↑↑↑↑↑↑↑↑ FIXUP SOMEDAY IN .DMD FILES
IF(IABS(J4).LT.80)GO TO 812
RSTJ2=.8*RSTJ2
C TO SET HGT. OF MINI CLEFS
R4=R4+CM(JEZ)
C SHIFTS MINIS UP BECAUSE OF WRONG ORIG. POS.??
812 IF(JEZ.NE.4)GO TO 811
R4=R4+2
JEZ=3
C ABOVE IS NOW AT TOP
811 A=R4
R4=A+2.9
C ADJUSTS HEIGHT(??)
CALL CENTX
R4=A
IF(NM.NE.NM1)GO TO 816
L=KPNT1(JEZ)
IF(L.LE.0)GO TO 817
GO TO 113
816 IF(NM.NE.NM2)GO TO 813
L=KPNT2(JEZ)
IF(L.LE.0)GO TO 817
L=L+350
GO TO 113
813 IF(NM.NE.NM3)GO TO 814
L=KPNT3(JEZ)
IF(L.LE.0)GO TO 817
L=L+700
GO TO 113
814 IF(NM.NE.NM4)GO TO 815
L=KPNT4(JEZ)
IF(L.LE.0)GO TO 817
L=L+1050
GO TO 113
CCC817 TYPE 818,J5
817 CALL TYPINT(J5)
CALL TYPSTR(' NOT FOUND *******')
CALL TYPCRLF
GO TO 334
CCC818 FORMAT(I4,' NOT FOUND *******')
CC IF(NM.NE.NM5)
815 L=KPNT5(JEZ)
IF(L.LE.0)GO TO 817
C CATCHES IMPOSSIBLE NUMBERS (I HOPE!)
L=L+1400
113 IF(J9.EQ.0)GO TO 31
C***** ROTATE *******
R7=R7*RSTJ2
R6=R6*RSTJ2
N=JCLEF(L)
KNT=701
C ROTATED DATA IS PUT STARTING AT LOCATION 701.(AREA FOR NM3)******
JCLEF(KNT)=N
DO 1 K=L+1,N+L-1
CALL UNPACK(J,M,JCLEF(K))
X=J*R6
Y=M*R7
JJ=JCLEF(K)/100000000
AX=ATAN2(X,Y)*57.29578
HYP=SQRT(X**2+Y**2)
ROT=DEG+AX
J=ROFF(HYP*COSD(ROT))
M=ROFF(HYP*SIND(ROT))
KNT=KNT+1
IF(J)J=1000-J
IF(M)M=1000-M
1 JCLEF(KNT)=M*10000+J+JJ*100000000
L=701
C *********** SEE AT TOP **********
R6=1.
R7=1.
RSTJ2=1.
C SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
CC CALL ROTATE(JCLEF,L)
NM3=0
C WIPES OUT DATA AREA FOR NM3
C R9=P9=DEGREES OF ROTATION (0-360)
IF(KK.GT.350)KX=0
C CHECK TO SEE IF DATA WAS WIPED OUT.
31 A=-1
C FLAG FOR THICKNESS OR NO.
IF(J8.EQ.-2)GO TO 32
IF(R8.LE.0)GO TO 34
A=0
CALL THICK
C THICK RETURNS NUMBER OF THICKNESSES IN J8 AND "SCALED" STEP IN R8
C NEXT J8 = 1→99 =X THICKNESS, =100→ = Y THICKNESS
CC J9=J8/100
CC J4=-1
C FLAG FOR SINGLE ADDED VERTICAL THICKNESS, NO MATTER WHAT SIZE. R8=.5
CC R8=AMOD(R8,100.0)
CC J8=R8
CC IF(R8.NE.J8)J4=0
CC R9=RSTJ2*DIS
C R8 AND R9 ARE FACTORS TO CAUSE RIGHT NUM OF LINES FOR THICKNESS.
CC J8=J8*R9
CC J9=J9*R9
CC IF(J9.NE.0.AND.J8.NE.0)J9=J8
C IF BOTH X AND Y THICKNESS IS USED THEY WILL BECOME EQUAL!
CC R8=1/DIS
CC IF(J4)GO TO 32
CC J9=1
C SINGLE ADDED THICKNESS, NO MATTER WHAT SIZE.
CC R8=1
GO TO 32
34 IF(IPLT)GO TO 77
IF(J8.NE.-1)GO TO 32
C J8=-2 OMITS FILLER DURING PLOT
77 DO 3 K=L+1,JCLEF(L)+L
IF(JCLEF(K).LT.200000000)GO TO 3
JEZ=JCLEF(L)-1
IF(K.GT.L+1)JEZ=JEZ-K+L+1
CALL FILLMS(JEZ,JCLEF(K),R3,CENTR,R6,R7)
GO TO 32
3 CONTINUE
C FILLS ONLY WHEN PLOTING OR R8=-1
32 CALL JDRAW(JCLEF(L),R3,CENTR,RSTJ2,R6,R7)
C 3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, R8=-1 TO FILL ON CRT
IF(A)GO TO 334
IF(J8.NE.0)GO TO 234
IF(J9.EQ.0)GO TO 334
GO TO 134
234 J8=J8-1
R3=R3+XDIS
C XDIS = 1 PLOTTER STEP
134 IF(J9.EQ.0)GO TO 32
J9=J9-1
CENTR=CENTR+XDIS
GO TO 32
334 IF(JTAIL)RETURN
JTAIL=-1
JA=10
JEZ=9
C JEZ=9 MAKES AN 8 APPEAR UNDER TAIL OF TREBLE CLEF.
R6=.2
R7=R6
NM='BDR40'
R3=R3+14*RSTJ2
R4=-4
GO TO 2
END
SUBROUTINE MOVER
IMPLICIT INTEGER(A-Q,S-Z)
DIMENSION IR(2,250)
REAL POS,EXTEN,PRCNT,ACCX
COMMON/RINP/R(2,250),NO(350),NP(250) /MKX/KSLA,ISEMI,LESS,IGT
C ARRAY NO(X) USED IN 'MOVIT'. HOLDS ALL POINTS TO BE MOVED AT ANY TIME.
COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/STF/RSTFAC(0/7),RSTJ2
1 /A2Z/LAA,LBB,LCC,A1(6),LJJ,LKK,LEL
COMMON/XRN/RN(1) /KJY/ KY,JY /JSTFY/ROV,PRCNT,RJSZ /IDEV/IDEV
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1 /POSI/STFF(0/7),JJ2,POS /LIMIT/LIMIT,ITEM,LL,I,IX/PTR/PWDS(1)
1 /ALF/INP(46),ACCX,ML,RRT,RZRO,NCNT,JSZ,OV,RSPC,KN,RA,RB,
1 JLDGR,LDGR,JX,RW,RX,RY,RZ,JJ,RD,RQ,RE,RZZ,RN3,RN6,RV,RQ6
EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
1,(R3,RJQ(1)),(R8,RJQ(6)),(R9,RJQ(7)),(R11,RJQ(9))
1,(IR,R)
DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/
CC DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/,RSP/.5/,RI/4.5/
JJ2=999
J2=0
ASK=-1
C 99=BACKUP
6 CALL VLINE(R2,R4,R5,R6)
IF(R2.GE.99)RETURN
IF(INP(1).EQ.LJJ)GO TO 12
CCC167 TYPE 5
167 CALL TYPSTR('TYPE NEW STAFF #, POS1, POS2, UP-DOWN # ')
CCC5 FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN # '$)
READ(IDEV,F78F,END=267)R7,R8,R9,R11
CQQ ACCEPT F78F,R7,R8,R9,R11
IF(R7.GE.99)GO TO 6
IF(R2.LE.7.AND.R7.GT.7)GO TO 167
C TRY AGAIN IF CONFUSION.
RDIS=0
REREAD FA1,L
C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
IF(L.EQ.LESS)GO TO 267
C < RETURN TO TTY MODE
IF(L.NE.IGT)GO TO 367
IDEV=1
GO TO 167
367 IF(L.EQ.LBB)GO TO 6
IF(R2.GT.7)R7=R2
IF(R7.EQ.R2)GO TO 1201
CALL TYPSTR('MOVED TO STAFF ')
CALL TYPFLT(R7)
CALL TYPCRLF
CCC IF(R7.NE.R2)TYPE 1200,R7
1201 IF(L.NE.LEL)GO TO 66
DO 67 K=1,2
R8=RY
CALL LPEN(R7,RY,RX)
67 IF(R7.GE.99)GO TO 6
R9=RY
CC66 JJ2=1
66 NST=1
C FOR START OF LOOP (1 UNLESS USING COPYIT)
IF(INP(1).NE.LCC)GO TO 68
NST=ITEM+1
CALL COPYIT
68 IF(R11.NE.0)CALL UPDN(NST)
JJ=0
IF(R4.NE.R8.OR.R5.NE.R9)JJ=-1
JY=0
C JY IS CHANGED IN GETPTS
IF(JJ)CALL GETPTS(NST)
IF(R2.NE.R7)CALL STFCH
IF(JY.NE.0)GO TO 1
7 IF(JJ2.EQ.999)JJ2=-1
RETURN
CC IF(JY.EQ.0)RETURN
1 CALL MOVIT(RN,NO,R4,R5,R8,R9)
RETURN
267 IDEV=5
GO TO 167
12 IF(R4.EQ.0)R4=.001
IF(R5.EQ.0)R5=200
NCNT=0
RRT=R5
RZRO=R4
RJSZ=4.5
CC RJSZ=RI
CALL GETPTS(1)
IF(JY.EQ.0)GO TO 7
C RETURN IF NO ITEMS FOUND TO DEAL WITH.
ROV=RRT
PRCNT=1.
CC R7=R2
R6=0
R11=0
19 IF(NCNT.GT.9)GO TO 101
RJSZ=RJSZ-.06
RP=PRCNT
NCNT=NCNT+1
C TEMPORARY COUNTER
CALL TYPINT(NCNT)
CALL TYPCHR(' ',2)
CCC TYPE F78F,RCNT
CALL JUSTFY(7,R,IR,NO,NP,RN,RSTFAC,R2,R4,R5,R6,R8,R9)
110 IF(ROV.LE.RRT+.01)GO TO 2
IF(RJSZ.GT.4)RJSZ=4
PRCNT=(ROV-RZRO)/(RRT-RZRO)
IF(PRCNT.NE.RP)GO TO 19
C GO BACK AND EXPAND SOME MORE
101 R4=RZRO
R5=ROV
R8=RZRO
R9=RRT-.001
C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
CALL MOVIT(RN,NO,R4,R5,R8,R9)
C RVX SHOULD BE FARTHEST POINT TO RIGHT.
CCC1200 FORMAT(' MOVED TO STAFF ',F4.0/)
CALL HYDPOG(3)
2 CALL TYPCRLF
END
SUBROUTINE READ(K)
COMMON NONO(29),JB(6),JP(6) /IDEV/IDEV /JCHAR/IXX,ISEMX,IBLA
COMMON /ALF/I(73) /MKX/KSLA,ISEMI/NUM/NUM(10)
1 /A2Z/AA,BB,LCC,NO(11),LOH
DATA NUM/'0','1','2','3','4','5','6','7','8','9'/,JRD/0/
EQUIVALENCE (N9,NUM(10))
14 IF(JRD)GO TO 2
IF(IDEV.NE.5)GO TO 1
15 CALL TYPSTR('TYPE @@ ')
CALL TYPCRLF
C IDEV=0 AFTER ';' IS SEEN.
1 READ(IDEV,10,END=2)I
IF(I(1).NE.LCC)GO TO 4
IF(I(2).NE.LOH)GO TO 4
C FOR X!Z% ET DIRECTORY
5 READ(1,10)I
IF(I(3).NE.ISEMI)GO TO 5
GO TO 1
4 IF(I(1).NE.N9)GO TO 11
IF(I(2).NE.N9)GO TO 11
C TYPE '99' TO BACKUP - ONE LINE ONLY EACH TIME.
DO 12 L=1,6
C GET BACK LAST POINTERS
12 JP(L)=JB(L)
IF(IDEV.EQ.5)CALL TYPCHR('RE',2)
GO TO 15
11 DO 16 K=73,1,-1
N=I(K)
16 IF(N.EQ.KSLA.OR.N.EQ.ISEMI)GO TO 17
GO TO 15
17 DO 9 L=1,K
C WIPE OUT COMMAS
9 IF(I(L).EQ.',')I(L)=IBLA
DO 13 L=1,5
C SAVE POINTERS FOR POSSIBLE BACKUP
13 JB(L)=JP(L)
CC DO 3 K=73,1,-1
CC N=I(K)
IF(N.EQ.ISEMI)JRD=-1
CC IF(N.NE.KSLA.AND.N.NE.ISEMI)GO TO 3
IF(IDEV.EQ.5)WRITE(21,10)(I(L),L=1,K)
C SAVE TYPED INPUT ON 'FOR21.DAT'
RETURN
CC3 CONTINUE
CC GO TO 1
C UNTERMINATED LINE (NO / OR ; )IS IGNORED. (FOR COMMENTS)
CC IF(I(1).NE.'@')GO TO 1
C START LINE WITH '@' FOR LITERAL REPRODUCTION.
CCC DO 6 K=73,1,-1
CCC6 IF(I(K).NE.' ')GO TO 7
CCC7 WRITE(23,10)(I(L),L=2,K)
CC TYPE 10,(I(L),L=1,K)
CCC CALL TYPARY(I,K)
CCC GO TO 1
C IGNORES BLANK LINES OR UNTERMINATED LINES.
10 FORMAT(73A1)
2 END FILE 23
IF(IDEV.EQ.5)END FILE 21
JRD=0
K=-1
END
SUBROUTINE OUTIT(I,K)
COMMON /MKX/KSLA,ISEMI /IDEV/IDEV
DIMENSION I(1)
IF(K.EQ.0)K=1
I(K)=';'
M=1
1 N=M+60
DO 2 L=N,M,-1
J=I(L)
2 IF(J.EQ.KSLA.OR.J.EQ.ISEMI)GO TO 3
3 IF(L.GT.K)L=K
WRITE(23,10)(I(J),J=M,L)
CC TYPE 11,(I(J),J=M,L)
CALL TYPARY(I(M),L-M+1)
IF(L.EQ.K)RETURN
M=L+1
GO TO 1
10 FORMAT(70A1)
CC11 FORMAT(1X70A1)
END